home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PBLIB1 / PROGS / DB.PAS < prev    next >
Pascal/Delphi Source File  |  1994-05-03  |  17KB  |  572 lines
  1. PROGRAM DB; {DBase Utility  ZAP/CLONE/SORT/CREATE/EXPORT/IMPORT }
  2.  
  3. {$M 30000,0,655000}
  4.  
  5. Uses DOS, CRT, PbCRT, PbMISC, PbDATA, PbOBJS, PbHIGH, PbPARMS, PbOUT1,
  6.           PbDBOBJ, PbDBLIB;
  7.  
  8. {
  9. Description : Combo DB Utility to save code space
  10.  
  11.  
  12. Author      : Howard Richoux
  13. Date        : 1/4/94
  14. Last revised: 1/4/94  1.00 Initial from DBSORT/DBZAP
  15.               1/4/94  1.02 Added DUMP/DDL/EXPORT/CREATE/CLONE
  16.               1/18/94 1.10 added KEYVALUE for DUMP
  17.               2/1/94  1.12 added DB DDL *
  18.               5/2/94  1.14 CREATE works, define SPEC= in parms
  19. Application : IBM PC and compatibles, done in Turbo Pascal 5.0
  20. Status      : Placed in the Public Domain by HNR Software 1/29/94
  21. Published in: none
  22. }
  23.  
  24.  
  25.  
  26. var   DBshowDDLflag  : boolean;    { a validation tool, shows rec struct }
  27.       DBDoItFlag     : boolean;    { OK to do the operation    }
  28.       DBProg         : string[20]; { Functional division of DB }
  29.  
  30.  
  31. { Global variables needed PRIMARILY for specific functions, can be used
  32.     by other functions - Named for their primary user. }
  33.  
  34. var DUMPTrimFlag    : boolean;     { if true, packs down fields, not as pretty,
  35.                                        but fits more per line }
  36. var DUMPRecNumFlag  : boolean;     { Do/Don't list record # }
  37.  
  38. var DUMPBetween     : string[5];   { what goes between fields on a DUMP }
  39.  
  40.  
  41.  
  42. Function VerifyStr(var fn : string; msg : string) : boolean;
  43. var recs,fields,recsize : integer;
  44.     eof                 : longint;
  45.      begin
  46.      ForceExt(fn,'dbf');
  47.      DBFGetClosedFileInfo(fn,recs,fields,recsize,eof);
  48.      writeln('File: [ ',fn,' ] has ',recs,' records.');
  49.      if CheckYesNo(msg,'Y') then
  50.           VerifyStr := true
  51.      else VerifyStr := false;
  52.      end;
  53.  
  54.  
  55. Function DecodeFNAME( p : integer; ext : string; var doit : boolean) : string;
  56. var fn : string;
  57.     i  : integer;
  58.      begin
  59.      doit := false;  fn := '';
  60.      if paramcount >= p then
  61.            begin
  62.            fn := paramstr(p);
  63.            i := pos('!',fn);
  64.            if i <> 0 then
  65.                 begin
  66.                 delete(fn,i,1);
  67.                 doit := true;
  68.                 end;
  69.            SuggestExt(fn,ext);
  70.            end
  71.      else writeln('File name not specified on param line.');
  72.      DecodeFNAME := UpCaseStr(fn);
  73.      end;
  74.  
  75.  
  76. {PAGE}
  77. Procedure DDLPrintHeader(var Y : DBF_object);
  78. var i,j : integer;
  79.     nam      : string;
  80.     fldtyp   : char;
  81.     ln,decp  : integer;
  82.     s        : string;
  83.     ch       : char;
  84.     begin
  85.     OUT(Y.filename+'   recsize='+integerstr(Y.recsize,4)+
  86.             ' bytes    records='+integerstr(Y.numrecs,4));
  87.     OUTSetIndent(15);
  88.     s := 'Fld#'+'  '+'Name         Type  Len  Decp';
  89.     OUT(s);
  90.     for i := 1 to Y.dbf.no_col do
  91.         begin
  92.         DBFDecodeFieldDef(Y.exportfielddefn(i),nam,fldtyp,ln,decp);
  93.         s := integerstr(i,4)+'  '+leftstr(nam,13)+'  '+fldtyp+'  '+
  94.              integerstr(ln,4);
  95.         if decp > 0 then s := s + '   ' + integerstr(decp,2);
  96.         OUT(s);
  97.         end;
  98.     OUT('      end');
  99.     OUTSetIndent(0);
  100.     end;
  101.  
  102.  
  103. Procedure DoOneDDL;
  104. var Y   : DBF_object;
  105.     begin
  106.     Y.init(pCurrFName,0,fREADWRITE);
  107.     if (Y.err = 0) then
  108.          begin
  109.          OUT(' ');
  110.          DDLPrintHeader(Y);
  111.          end
  112.     else writeln('Unable to open database [',pCurrFName,']');
  113.     Y.done;
  114.     end;
  115.  
  116.  
  117. Procedure GoOnDDL;
  118. var s : string;
  119.     i,j : integer;
  120.     files : STRA_object;
  121.     begin
  122.     OUT(pProgID+' DDL - Data Dictionary Listing ');
  123.     OUT(' ');
  124.     s := pCurrFName;
  125.     suggestext(s,'dbf');
  126.     i := pos('*',s);
  127.     j := pos('?',s);
  128.     if (i > 0) or (j > 0) then
  129.          begin
  130.          files.init(20);
  131.          GetFilesSTRA(s,files,fSortByName);
  132.          for i := 1 to files.count do
  133.               begin
  134.               pCurrFName := files.fetchN(i);
  135.               suggestext(pCurrFName,'dbf');
  136.               DoOneDDL;
  137.               OUT(' ');
  138.               OUT(' ');
  139.              { OUTDoneWithPage;}
  140.               end;
  141.          end
  142.     else begin
  143.          DoOneDDL;
  144.          end;
  145.     end;
  146.  
  147. {PAGE}
  148. Procedure DUMPPrintHeader(var X : KEYED_DBF_object; trimflag : boolean;
  149.                           var flist : HOLD_object);
  150. var j,fld,len : integer;
  151.     s,s1,nam    : string;
  152.      begin
  153.      OUT(' ');
  154.      OUT(pProgID+'   file= '+X.filename+'    recsize='+integerstr(X.recsize,4)+
  155.                           '   total recs='+integerstr(X.numrecs,5));
  156.      OUT(' ');
  157.      s := DBFFmtDumpRecNum(0,1,trimflag,DUMPRecNumFlag,DUMPBetween);
  158.      j := 1;
  159.      while (j <= flist.count) and (j <= X.dbf.dbnumfields) do
  160.           begin
  161.           nam := flist.fetchstrN(j);
  162.           fld := DBFDecodeFldName(x,nam);
  163.           if fld > 0 then
  164.                begin
  165.                len := flist.fetchnumN(j);
  166.                if len > 0 then
  167.                     s1 := leftstr(X.dbf.dbfldname(fld),len)
  168.                else s1 := leftstr(X.dbf.dbfldname(fld),X.dbf.dbfldwidth(fld));
  169.               { s1 := '('+integerstr(fld,2)+')';} {debugging}
  170.                end
  171.           else s1 := '?';
  172.           if trimflag then trim(s1);
  173.           s := s + s1 + DUMPBetween;
  174.           inc(j);
  175.           end;
  176.      if j > 1 then delete(s,(length(s)-length(DUMPBetween))+1,length(DUMPBetween));
  177.      OUT(s);
  178.  
  179.      s := DBFFmtDumpRecNum(0,2,trimflag,DUMPRecNumFlag,DUMPBetween);
  180.      j := 1;
  181.      while (j <= flist.count) and (j <= X.dbf.dbnumfields) do
  182.           begin
  183.           nam := flist.fetchstrN(j);
  184.           fld := DBFDecodeFldName(x,nam);
  185.           if fld > 0 then
  186.                begin
  187.                len := flist.fetchnumN(j);
  188.                s1 := conststr('-',40);
  189.                if len > 0 then
  190.                     s1 := leftstr(s1,len)
  191.                else s1 := leftstr(s1,X.dbf.dbfldwidth(fld));
  192.                end
  193.           else s1 := '';
  194.           if trimflag then trim(s1);
  195.           s := s + s1 + DUMPBetween;
  196.           inc(j);
  197.           end;
  198.      if j > 1 then delete(s,(length(s)-length(DUMPBetween))+1,length(DUMPBetween));
  199.      OUT(s);
  200.      end;
  201.  
  202.  
  203. Procedure DUMPPrintRecs(var X : KEYED_DBF_object; trimflag : boolean;
  204.                         var flist : HOLD_object; first,last : integer);
  205. var i,j,k,fld,len  : integer;
  206.     s,s1,kval : string;
  207.     ok        : boolean;
  208.     kflds        : HOLD_object;
  209.     begin
  210.     if DBFKeyValue <> '*' then
  211.          begin
  212.          kflds.init(10);
  213.          FStringToFList(DBFKeySpec,X,kflds)
  214.          end;
  215.     s := '';
  216.     i := first;
  217.     if i < 1 then i := 1;
  218.     while (i <= last) and (i <= X.numrecs) do
  219.          begin
  220.          ok := X.fetchn(i);
  221.          if not ok then writeln('fetchn error ',X.err);
  222.          if DBFKeyValue <> '*' then
  223.               begin
  224.               kval := FListDataStr(kflds,X);
  225.               ok   := Compare(kval,DBFKeyValue);
  226.               end;
  227.          if ok then
  228.               begin
  229.               s := DBFFmtDumpRec(x,flist,trimflag,DUMPRecNumFlag,DUMPBetween);
  230.               OUT(s);
  231.               end;
  232.          inc(i);
  233.          end;
  234.     OUT(' ');
  235.     end;
  236.  
  237.  
  238. Procedure GoOnDUMP;
  239. var X  : KEYED_DBF_object;
  240.     begin
  241.     if not FileExists(pCurrFName) then
  242.          begin
  243.          writeln('file does not exist. [',pCurrFName,']');
  244.          exit;
  245.          end;
  246.     X.init(pCurrFName,0,fREADONLY,DBFKeytag,DBFKeySpec,DBFKeyMax);
  247.     if X.err = 0 then
  248.          begin
  249.          if DBFKeyValue <> '*' then
  250.               begin
  251.               DBFKeySpec := UpCaseStr(DBFKeySpec);
  252.               if (DBFKeySpec = '') then
  253.                    begin
  254.                    OUT('ERROR - You must specify a KEYSPEC=[...] '+
  255.                        'param to use KEYVALUE='+DBFKeyValue);
  256.                    exit;
  257.                    end;
  258.               DBFKeyValue := UpCaseStr(DBFKeyValue);
  259.               OUT('Printing where ['+DBFKeySpec+'] ='+DBFKeyValue);
  260.               end;
  261.          DBFDecodeFString(DBFFstring,X,DBFFlist);
  262.          DUMPPrintHeader(X,DUMPTrimFlag,DBFFlist);
  263.          DUMPPrintRecs(X,DUMPTrimFlag,DBFFlist,pfirst,pLast);
  264.          end
  265.     else writeln('Unable to open database [',pCurrFName,']');
  266.     X.done;
  267.     end;
  268.  
  269.  
  270. {PAGE}
  271. Procedure EXPORTPrintHeader(var X : KEYED_DBF_object;var flist : HOLD_object);
  272. var s,s1 : string;
  273.      begin
  274.      s  := DBFExportHeaderStr(X,flist);
  275.      s1 := BreakLineChr(s,77,',');
  276.      OUT(s1);
  277.      While length(s) > 0 do
  278.           begin
  279.           s1 := BreakLineChr(s,77,',');
  280.           OUT(' '+s1);
  281.           end;
  282.      end;
  283.  
  284.  
  285. Procedure EXPORTPrintRec(n : integer;var X : DBF_object;
  286.                                      var flist : HOLD_object);
  287. var s,s1 : string;
  288. var ok   : boolean;
  289.      begin
  290.      ok := X.fetchn(n);
  291.      if not ok then OUT('fetchn error '+integerstr(X.err,4)+' ['+
  292.                             integerstr(n,4)+']')
  293.      else begin
  294.           s  := DBFFmtDumpRec(X,flist,true,false,',');
  295.           s1 := BreakLineChr(s,77,',');
  296.           if length(s) > 0 then OUT('['+s1)
  297.           else                  OUT('['+s1+']');
  298.           While length(s) > 0 do
  299.                begin
  300.                s1 := BreakLineChr(s,77,',');
  301.                if length(s) > 0 then OUT(' '+s1)
  302.                else                  OUT(' '+s1+']');
  303.                end;
  304.           end;
  305.      end;
  306.  
  307.  
  308. Procedure EXPORTPrintRecs(var X : KEYED_DBF_object;var flist : HOLD_object;
  309.                           first,last : integer);
  310. var i,j,k,fld,len  : integer;
  311.     s,s1 : string;
  312.     ok : boolean;
  313.     begin
  314.     s := '';
  315.     i := first;
  316.     if i < 1 then i := 1;
  317.     while (i <= last) and (i <= X.numrecs) do
  318.          begin
  319.          EXPORTPrintRec(i,X,flist);
  320.          inc(i);
  321.          end;
  322.     OUT(' ');
  323.     end;
  324.  
  325.  
  326. Procedure GoOnEXPORT;
  327. var X  : KEYED_DBF_object;
  328.     begin
  329.     X.init(pCurrFName,0,fREADONLY,DBFKeytag,DBFKeySpec,DBFKeyMax);
  330.     if X.err = 0 then
  331.          begin
  332.          DBFDecodeFString(DBFFstring,X,DBFFlist);
  333.          EXPORTPrintHeader(X,DBFFlist);
  334.          EXPORTPrintRecs(X,DBFFlist,pfirst,pLast);
  335.          end
  336.     else writeln('Unable to open database [',pCurrFName,']');
  337.     X.done;
  338.     end;
  339.  
  340.  
  341. {PAGE}
  342. Procedure GoOnCREATE;
  343. var err : integer;
  344.      begin
  345.      if pDebug then writeln('GoOnCREATE [',pCurrFName,']');
  346.      if pCurrFName = '' then exit;
  347.      pCurrFName := DecodeFNAME( 2,'dbf',DBDoItFlag);
  348.      if FileExists(pCurrFName) then
  349.           begin
  350.           writeln('File Already exists. [',pCurrFName,']');
  351.           exit;
  352.           end;
  353.      if pDebug then writeln('DBFFstring {',DBFFstring,'}');
  354.      if DBFCreateFile(pCurrFName, DBFFstring, err) then
  355.           begin
  356.           DBFShowStructure(pCurrFName);
  357.           end
  358.      else writeln('DBFCreateFile failed. [',pCurrFName,']');
  359.      end;
  360.  
  361.  
  362. Procedure GoOnCLONE;
  363. var fn2 : string;
  364.      begin
  365.      if pDebug then writeln('GoOnCLONE [',pCurrFName,']');
  366.      if pCurrFName = '' then exit;
  367.      if not FileExists(pCurrFName) then
  368.           begin
  369.           writeln('Unable to find file to be CLONEd: [',pCurrFName,']');
  370.           exit;
  371.           end;
  372.      fn2 := DecodeFNAME( 3,'dbf',DBDoItFlag);
  373.      if DBFCLONEFile(pCurrFName, fn2) then
  374.           begin
  375.           DBFShowStructure(fn2);
  376.           end
  377.      else writeln('DBFCloneFile failed. [',pCurrFName,']');
  378.      end;
  379.  
  380.  
  381.  
  382. Procedure GoOnZAP;
  383. var recs,fields,recsize : integer;
  384.     eof                 : longint;
  385.      begin  { already have DOIT! }
  386.      if pDebug then writeln('GoOnZAP [',pCurrFName,']');
  387.      if pCurrFName = '' then exit;
  388.      if not FileExists(pCurrFName) then
  389.           begin
  390.           writeln('Unable to find file to be ZAPped: [',pCurrFName,']');
  391.           exit;
  392.           end;
  393.      if DBFZapFile(pCurrFName) then
  394.           begin
  395.           DBFGetClosedFileInfo(pCurrFName,recs,fields,recsize,eof);
  396.           if recs = 0 then
  397.                begin
  398.                writeln('DBFZapFile OK. [',pCurrFName,']');
  399.                writeln('');
  400.                end
  401.           else begin
  402.                writeln('DBFZapFile reported OK. [',pCurrFName,']');
  403.                writeln('SOMETHING WRONG, ',pCurrFName,' shows ',recs,' records.');
  404.                writeln('');
  405.                end;
  406.           if DBshowDDLflag then DBFShowStructure(pCurrFName);
  407.           end
  408.      else writeln('DBFZapFile failed. [',pCurrFName,']');
  409.      end;
  410.  
  411. {PAGE}
  412.  
  413.  
  414. Procedure GoOnSORT;
  415.      begin
  416.      if pDebug then writeln('GoOnSORT [',pCurrFName,']');
  417.      if pCurrFName = '' then exit;
  418.      if not FileExists(pCurrFName) then
  419.           begin
  420.           writeln('Unable to find file to be sorted: [',pCurrFName,']');
  421.           exit;
  422.           end;
  423.      if DBFSORTFile(pCurrFName,DBFKeyTag,DBFKeySpec) then
  424.           begin
  425.           writeln('DBFSORTFile OK. [',pCurrFName,']');
  426.           writeln('');
  427.           if DBshowDDLflag then DBFShowStructure(pCurrFName);
  428.           end
  429.      else writeln('DBFSORTFile failed. [',pCurrFName,']');
  430.      end;
  431.  
  432.  
  433. Procedure GoOnSELFTEST;
  434. var err : integer;
  435.     dbf : KEYED_DBF_object;
  436.     dbf2 : DBF_object;
  437.      begin
  438.      if pDebug then writeln('GoOnSELFTEST [',pCurrFName,']');
  439.      pCurrFName := 'junkfile.dbf';
  440.      DBFFstring := '[field1(c20),field2(n10.2)]';
  441.      if FileExists(pCurrFName) then EraseFile(pCurrFName);
  442.      if DBFCreateFile(pCurrFName, DBFFstring, err) then
  443.           begin
  444.           DBFShowStructure(pCurrFName);
  445.           end
  446.      else writeln('DBFCreateFile failed. [',pCurrFName,']');
  447.      dbf2.init(pCurrFName,0,fREADWRITE);
  448.      if dbf2.NoError then
  449.           begin
  450.           dbf2.dbf.dbputstr (1,'abcdefg'); dbf2.dbf.dbputreal(2,123.45);
  451.           dbf2.append;
  452.           dbf2.dbf.dbputstr (1,'ABCDEFGH'); dbf2.dbf.dbputreal(2,987.65);
  453.           dbf2.append;
  454.           dbf2.dbf.dbputstr (1,'1234abcd'); dbf2.dbf.dbputreal(2,1.23);
  455.           dbf2.append;
  456.           end;
  457.      if dbf2.NoError then
  458.           begin
  459.           DBFDecodeFString('[*]',dbf2,DBFFlist);
  460.           end;
  461.      dbf2.done;
  462.      dbf.init(pCurrFName,0,fREADWRITE,'','',100);
  463.      if dbf.err = 0 then
  464.           begin
  465.           DBFDecodeFString(DBFFstring,dbf,DBFFlist);
  466.           DUMPPrintHeader(dbf,DUMPTrimFlag,DBFFlist);
  467.           DUMPPrintRecs(dbf,DUMPTrimFlag,DBFFlist,pfirst,pLast);
  468.           end
  469.      else writeln('Unable to open database [',pCurrFName,']');
  470.      dbf.done;
  471.      end;
  472.  
  473.  
  474. {PAGE}
  475.  
  476. Procedure GoOn;
  477.      begin
  478.      pCurrFName := DecodeFNAME( 2,'dbf',DBDoItFlag);
  479.      if      DBProg = 'SORT' then
  480.           begin
  481.           writeln('File will be sorted using KEYSPEC= [',DBFKeySpec,']');
  482.           if not DBDoItFlag then DBDoItFlag :=
  483.               VerifyStr(pCurrFName,'Do you wish to SORT these records? ');
  484.           if DBDoItFlag then GoOnSORT;
  485.           end
  486.      else if DBProg = 'ZAP' then
  487.           begin
  488.           if not DBDoItFlag then DBDoItFlag :=
  489.               VerifyStr(pCurrFName,'Do you wish to DELETE ALL records? ');
  490.           if DBDoItFlag then GoOnZAP;
  491.           end
  492.      else if DBProg = 'CREATE' then
  493.           begin
  494.           GoOnCREATE;
  495.           end
  496.      else if DBProg = 'DDL' then
  497.           begin
  498.           GoOnDDL;
  499.           end
  500.      else if DBProg = 'DUMP' then
  501.           begin
  502.           GoOnDUMP;
  503.           end
  504.      else if DBProg = 'EXPORT' then
  505.           begin
  506.           GoOnEXPORT;
  507.           end
  508.      else if DBProg = 'CLONE' then
  509.           begin
  510.           GoOnCLONE;
  511.           end
  512.      else if DBProg = 'SELFTEST' then
  513.           begin
  514.           GoOnSELFTEST;
  515.           end
  516.      else begin
  517.           writeln('Unrecognized Function [',DBProg,']  Type DB(cr) for help');
  518.           end
  519.      end;
  520.  
  521.  
  522.  
  523. Procedure Init;
  524. var i : integer;
  525.     s : string;
  526.      begin
  527.      DBProg := '';
  528.      DBFFlist.init(127);  {allow for up to 127 fields }
  529.      DBFKeyTag := '';
  530.      DBFKeySpec := '';
  531.      DBDoItFlag := false;
  532.  
  533.      AddParm(1,'SHOWSTRUCT','NO');
  534.      AddParm(1,'RECNUM','YES');
  535.      AddParm(1,'COMPRESSED','YES');
  536.      AddParm(1,'TRIM','NO');
  537.      AddParm(1,'SPEC','[*]');  {FIELDS}
  538.      AddParm(1,'BETWEEN','[ | ]');
  539.  
  540.      DBFAddParms;
  541.      StandardOUTInit;
  542.      DBFGetParms;
  543.      PARMSetFirstLast;
  544.  
  545.      s              := GetParmStr('BETWEEN');
  546.      DBFFstring     := GetParmStr('SPEC');
  547.      DUMPBetween    := ExtractDelimitedStr(s,'[',']');
  548.      DUMPTrimFlag   := CheckOK('TRIM');
  549.      DUMPRecNumFlag := CheckOK('RECNUM');
  550.      DBshowDDLflag  := checkok('SHOWSTRUCT');
  551.  
  552.      if paramcount > 0 then
  553.            begin
  554.            DBProg := UpCaseStr(paramstr(1));
  555.            end;
  556.  
  557.      if pDEBUG then OUT('Using field list = '+DBFFstring);
  558.      end;
  559.  
  560.  
  561. (*  Main program *)
  562.      BEGIN
  563.      pProgID := 'DB 1.14';
  564.      writeln('xBase - DBF - DDL/SORT/ZAP/CLONE/EXPORT/IMPORT/CREATE   12/93');
  565.      Init;
  566.      if paramcount > 1 then GoOn     {minimum DB <FUNCTION> <file> }
  567.      else ShowDocFile;
  568.      OUTDone;
  569.      end.
  570.  
  571.  
  572.